home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / generate.em < prev    next >
Lisp/Scheme  |  1993-07-13  |  11KB  |  426 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: generate.em
  4. ;; Date: Wed Jan  8 16:59:29 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;    Functions that modify the state by adding instructions 
  9. ;;
  10. (defmodule generate
  11.   (standard0
  12.    list-fns
  13.          
  14.    compstate
  15.    instruct
  16.    stream
  17.    
  18.    ;;rshow
  19.    )
  20.   ()
  21.   (expose compstate)
  22.   (export make-label)
  23.  
  24.   ;; normal bytecodes
  25.   (defun do-nop (obj state)
  26.     (modify-compiler-state state
  27.                'state-stream (add-instruction (nop nil) (state-stream state))))
  28.   
  29.   (defun do-push-global (name state)
  30.     (update-comp-state state
  31.      (lambda (stack)
  32.        (stack-push stack name))
  33.      (lambda (stream)
  34.        (add-instruction (push-global (list name))
  35.             stream))))
  36.  
  37.   (defun do-global-set (name state)
  38.     (update-comp-state 
  39.      state
  40.      (lambda (stack)
  41.        (stack-pop stack 1))
  42.      (lambda (stream)
  43.        (add-instruction (set-global (list name)) stream))))
  44.  
  45.   (defun do-push-label (label state)
  46.     (update-comp-state state
  47.      (lambda (stack)
  48.        (stack-push (stack-push stack label) label))
  49.      (lambda (stream)
  50.        (let ((i (push-label (list label))))
  51.      (add-lab-ref label i)
  52.      (add-instruction i stream)))))
  53.  
  54.   (defun do-apply-bvf (nargs state)
  55.     (update-comp-state state
  56.      (lambda (stack) stack)
  57.      (lambda (stream) 
  58.        (add-instruction (apply-bvf (list nargs))
  59.             stream))))
  60.  
  61.   (defun do-apply-any (nargs state)
  62.     (update-comp-state state
  63.      (lambda (stack) stack)
  64.      (lambda (stream)
  65.        (add-instruction (apply-any (list nargs))
  66.             stream))))
  67.  
  68.   (defun do-apply-cfn (nargs state)
  69.     (update-comp-state state
  70.      (lambda (stack) stack)
  71.      (lambda (stream)
  72.        (add-instruction (apply-cfn (list nargs))
  73.             stream))))
  74.  
  75.   (defun do-apply-methods (nargs state)
  76.     (update-comp-state state
  77.      (lambda (stack) stack)
  78.      (lambda (stream)
  79.        (add-instruction (apply-methods (list nargs))
  80.             stream))))
  81.  
  82.   (defun do-return (state)
  83.     (update-comp-state 
  84.      state
  85.      (lambda (stack) 
  86.        ;; right?
  87.        stack)
  88.      (lambda (stream)
  89.        (add-instruction (return nil) stream))))
  90.  
  91.   (defun do-pop (count state)
  92.     (update-comp-state state
  93.      (lambda (stack)
  94.        (stack-pop stack count))
  95.      (lambda (stream)
  96.        (add-instruction (drop (list count)) stream))))
  97.     
  98.   (defun do-slide (low keep state)
  99.     (if (= low keep)
  100.     state
  101.       (update-comp-state 
  102.        state
  103.        (lambda (stack)
  104.      (stack-slide stack low keep))
  105.        (lambda (stream)
  106.      (add-instruction (i-slide-stack (list low keep)) stream)))))
  107.  
  108.   (defun do-stack-ref (count state)
  109.     (update-comp-state state
  110.      (lambda (stack)
  111.        (stack-push stack
  112.            (stack-ref (state-stack state)
  113.                   count)))
  114.      (lambda (stream)
  115.        (add-instruction (nth-ref (list count)) stream))))
  116.  
  117.   (defun do-set-stack-ref (count state)
  118.     (update-comp-state 
  119.      state
  120.      (lambda (stack) (stack-pop stack 1))
  121.      (lambda (stream)
  122.        (add-instruction (set-nth (list count)) stream))))
  123.  
  124.   (defun do-swap (state)
  125.     (update-comp-state
  126.      state
  127.      stack-swap
  128.      (lambda (stream)
  129.        (add-instruction (swap nil) stream))))
  130.  
  131.   ;; Primitive functions
  132.  
  133.   (defun do-cons (state)
  134.     (update-comp-state state
  135.      (lambda (stack)
  136.        (stack-push (stack-pop stack 2) (make-stack-val)))
  137.      (lambda (stream)
  138.        (add-instruction (i-cons nil) stream))))
  139.  
  140.   (defun do-alloc (state)
  141.     (update-comp-state state
  142.      (lambda (stack)
  143.        (stack-pop stack 2))
  144.      (lambda (stream)
  145.        (add-instruction (alloc-thing nil) stream))))
  146.  
  147.   (defun do-car (state)
  148.     (update-comp-state state
  149.      (lambda (stack)
  150.        (stack-push (stack-pop stack 1) (make-stack-val)))
  151.      (lambda (stream)
  152.        (add-instruction (slot-ref (list 0)) stream))))
  153.  
  154.  
  155.   (defun do-cdr (state)
  156.     (update-comp-state state
  157.      (lambda (stack)
  158.        (stack-push (stack-pop stack 1) (make-stack-val)))
  159.      (lambda (stream)
  160.        (add-instruction (slot-ref (list 1))
  161.             stream))))
  162.   
  163.   
  164.  
  165.   (defun do-slot-ref (n state)
  166.     (update-comp-state state
  167.      (lambda (stack)
  168.        (stack-push (stack-pop stack 1) (make-stack-val)))
  169.      (lambda (stream)
  170.        (add-instruction (slot-ref (list n))
  171.             stream))))
  172.   
  173.   ;; leaves its arg on the stack
  174.   (defun do-setter-slot-ref (n state)
  175.     (update-comp-state state
  176.      (lambda (stack)
  177.        (stack-push (stack-pop stack 2) (stack-top stack)))
  178.      (lambda (stream)
  179.        (add-instruction (set-slot (list n))
  180.             stream))))
  181.  
  182.   (defun do-setter-cdr (state)
  183.     (do-setter-slot-ref 1 state))
  184.  
  185.   ;; Special constants
  186.   (defun do-push-special (state const)
  187.     nil)
  188.  
  189.   (defun do-dead-code (state)
  190.     (update-comp-state state
  191.      (lambda (stack)
  192.        stack)
  193.      (lambda (stream)
  194.        (add-instruction (dead-code ()) stream))))
  195.     
  196.   ;; Random things
  197.   (defun special-id (x)
  198.     (if (eq x ()) 0
  199.       1))
  200.  
  201.   (defun do-push-static (static state)
  202.     (if (or (eq static nil)
  203.         (eq static t))
  204.     (update-comp-state state
  205.                (lambda (stack)
  206.                  (stack-push (state-stack state) static))
  207.                (lambda (stream) 
  208.                  (add-instruction (push-special (list (special-id static))) stream)))
  209.       (let ((new-statics (add-static static
  210.                      (state-statics state))))
  211.     (modify-compiler-state
  212.      state
  213.      'state-stack 
  214.      (stack-push (state-stack state) static)
  215.      'state-stream
  216.      (add-instruction (push-static (list (static-val-id (car new-statics))))
  217.               (state-stream state))
  218.      'state-statics (cadr new-statics)))))
  219.        
  220.   (defun do-push-fixnum (n state)
  221.     (update-comp-state state
  222.                (lambda (stack) 
  223.              (stack-push stack n))
  224.                (lambda (stream)
  225.              (add-instruction (push-fixnum (list n)) stream))))
  226.  
  227.                ;;  (defun do-load-tmp (state)
  228. ;;    (modify-compiler-state 
  229. ;;     state 'state-stack 
  230. ;;     (stack-pop (state-stack state)
  231. ;;        count)))
  232. ;;    
  233. ;;  (defun do-unload-tmp (state)
  234. ;;    (modify-compiler-state 
  235. ;;     state
  236. ;;     'state-stack (stack-push (state-stack state)
  237. ;;                  (make-stack-val))))
  238.     
  239.  
  240.   (defun do-vector-ref (static state)
  241.     nil)
  242.   
  243.   (defun do-add-comment (comment state)
  244.     nil)
  245.  
  246.   ;; allocating closures
  247.  
  248.   (defun do-allocate-closure (argcode ext state)
  249.     (update-comp-state 
  250.      state
  251.      (lambda (stack)
  252.        (stack-push (stack-pop stack (if ext 4 3)) ;; pop label(2)+env+info?
  253.            (make-stack-val)))
  254.      (lambda (stream)
  255.        (add-instruction (if ext
  256.                 (alloc-extended-closure (list (argcode2other argcode)))
  257.               (alloc-closure (list (argcode2other argcode))))
  258.             stream))))
  259.  
  260.   (defun argcode2other (x)
  261.     (if (null (car x)) 
  262.     (cdr x) 
  263.       (- (cdr x))))
  264.  
  265.           
  266.   ;; env functions
  267.   (defun do-alloc-env (env state)
  268.     (let ((size (env-object-size env)))
  269.       (format t "{Making Env: ~a " size)
  270.       (prog1 (update-comp-state 
  271.           state
  272.           (lambda (stack)
  273.         (let ((prev (stack-top stack)))
  274.           (stack-push (stack-pop stack 1) env)))
  275.           (lambda (stream)
  276.         (print stream)
  277.         (add-instruction (make-env (list size)) stream)))
  278.     nil)))
  279.  
  280.   (defun do-env-ref (x y state)
  281.     (update-comp-state state
  282.      (lambda (stack)
  283.        (stack-push (stack-pop stack 1)
  284.            (compile-env-ref x y (stack-top stack))))
  285.      (lambda (stream)
  286.        (add-instruction (env-ref (list x y))
  287.             stream))))
  288.   
  289.   (defun do-setter-env-ref (x y state)
  290.     ;; stack is ... env value
  291.     (update-comp-state state
  292.      (lambda (stack)
  293.        (compile-env-ref-set x y (stack-ref stack 1) (stack-top stack))
  294.        (stack-pop stack 1))
  295.      (lambda (stream)
  296.        (add-instruction (set-env (list x y))
  297.             stream))))
  298.  
  299.  
  300.   (defun do-pop-env (n state)
  301.     (update-comp-state
  302.      state
  303.      (lambda (stack)
  304.        (stack-push (stack-pop stack 1)
  305.            (compile-nth-env n (stack-top stack))))
  306.      (lambda (stream)
  307.        (add-instruction (pop-env (list n)) stream))))
  308.  
  309.   (defun compile-nth-env (n env)
  310.     (if (zerop (env-object-size env))
  311.     (compile-nth-env n (env-object-prev env))
  312.       (if (= n 0)  env
  313.     (compile-nth-env (- n 1) 
  314.              (env-object-prev env)))))
  315.  
  316.   (defun compile-env-ref-set (x y env val)
  317.     ((setter vector-ref) (env-object-content (compile-nth-env x env)) y val))
  318.  
  319.   (defun compile-env-ref (x y env)
  320.     (vector-ref (env-object-content (compile-nth-env x env)) y))
  321.  
  322.   ;; labels and such
  323.  
  324.   (defun do-add-label (lab state)
  325.     (modify-compiler-state 
  326.      state
  327.      'state-stream (add-instruction (i-label (list lab) )
  328.                     (state-stream state))))
  329.  
  330.   (defun do-branch (lab state)  
  331.     (update-comp-state state
  332.      (lambda (stack)
  333.        stack)
  334.      (lambda (stream)
  335.        (let ((i (branch (list lab))))
  336.      (add-lab-ref lab i)
  337.      (add-instruction i
  338.               (state-stream state))))))
  339.  
  340.  
  341.   (defun do-branch-on-nil (lab state)
  342.     (update-comp-state state
  343.      (lambda (stack)
  344.        (stack-pop stack 1))
  345.      (lambda (stream)
  346.        (let ((i (branch-nil (list lab))))
  347.      (add-lab-ref lab i)
  348.      (add-instruction i
  349.               (state-stream state))))))
  350.   
  351.   (defun do-inline-code (lst nargs state)
  352.     (let ((xx (state-stream state))
  353.       (yy (state-stack state)))
  354.       (modify-compiler-state 
  355.        state
  356.        'state-stream (fold (lambda (desc stream)
  357.                  (add-instruction (make-instruction desc) stream))
  358.                (if (and (consp lst)
  359.                     (eq (car lst) 'returning))
  360.                    (cdr lst)
  361.                  lst)
  362.                xx)
  363.        'state-stack
  364.        (stack-push (stack-pop yy nargs) (make-stack-val)))))
  365.  
  366.   (defun make-instruction (desc)
  367.     ((find-instruction (car desc)) (cdr desc)))
  368.  
  369.   ;; utility functions...
  370.   (defun do-code-sequence (lst state)
  371.     (fold (lambda (fn state)
  372.         (fn state))
  373.       lst 
  374.       state))
  375.  
  376.   ;; Operations of the code-stream
  377.   ;; Could use tconc, but what the hell
  378.   (defun make-new-code-stream ()
  379.     (make-simple-stream))
  380.   
  381.   (export make-new-code-stream)
  382.   
  383.  
  384.   (export do-code-sequence)
  385.   
  386.   (export do-allocate-closure)
  387.   (export do-push-global)
  388.   (export do-push-static)
  389.   (export do-push-fixnum)
  390.   (export do-global-set)
  391.   (export do-nop)
  392.   (export do-pop)
  393.   (export do-apply-any)
  394.   (export do-apply-cfn)
  395.   (export do-apply-bvf)
  396.   (export do-apply-methods)
  397.   (export do-stack-ref)
  398.   (export do-set-stack-ref)
  399.   (export do-alloc)
  400.   (export do-cons)
  401.   (export do-car)
  402.   (export do-cdr)
  403.   (export do-slot-ref)
  404.   (export do-setter-slot-ref)
  405.   (export do-setter-cdr)
  406.   (export do-vector-ref)
  407.   (export do-add-comment)
  408.   (export do-alloc-env)
  409.   (export do-env-ref)
  410.   (export do-setter-env-ref)
  411.   (export do-pop-env)
  412.   (export do-add-label)
  413.   (export do-branch)
  414.   (export do-branch-on-nil)
  415.   (export do-code-sequence)
  416.   (export do-push-label)
  417.   (export do-return)
  418.   (export do-slide)
  419.   (export do-swap)
  420.   (export do-inline-code)
  421.   (export do-dead-code)
  422.  
  423.   (export  bc-macro-type)
  424.   ;; end module
  425.   )
  426.